home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / perl5 / 5.8.7 / File / Spec / VMS.pm < prev    next >
Text File  |  2006-04-25  |  16KB  |  543 lines
  1. package File::Spec::VMS;
  2.  
  3. use strict;
  4. use vars qw(@ISA $VERSION);
  5. require File::Spec::Unix;
  6.  
  7. $VERSION = '1.4';
  8.  
  9. @ISA = qw(File::Spec::Unix);
  10.  
  11. use File::Basename;
  12. use VMS::Filespec;
  13.  
  14. =head1 NAME
  15.  
  16. File::Spec::VMS - methods for VMS file specs
  17.  
  18. =head1 SYNOPSIS
  19.  
  20.  require File::Spec::VMS; # Done internally by File::Spec if needed
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. See File::Spec::Unix for a documentation of the methods provided
  25. there. This package overrides the implementation of these methods, not
  26. the semantics.
  27.  
  28. =over 4
  29.  
  30. =item eliminate_macros
  31.  
  32. Expands MM[KS]/Make macros in a text string, using the contents of
  33. identically named elements of C<%$self>, and returns the result
  34. as a file specification in Unix syntax.
  35.  
  36. =cut
  37.  
  38. sub eliminate_macros {
  39.     my($self,$path) = @_;
  40.     return '' unless $path;
  41.     $self = {} unless ref $self;
  42.  
  43.     if ($path =~ /\s/) {
  44.       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
  45.     }
  46.  
  47.     my($npath) = unixify($path);
  48.     my($complex) = 0;
  49.     my($head,$macro,$tail);
  50.  
  51.     # perform m##g in scalar context so it acts as an iterator
  52.     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
  53.         if ($self->{$2}) {
  54.             ($head,$macro,$tail) = ($1,$2,$3);
  55.             if (ref $self->{$macro}) {
  56.                 if (ref $self->{$macro} eq 'ARRAY') {
  57.                     $macro = join ' ', @{$self->{$macro}};
  58.                 }
  59.                 else {
  60.                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
  61.                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
  62.                     $macro = "\cB$macro\cB";
  63.                     $complex = 1;
  64.                 }
  65.             }
  66.             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
  67.             $npath = "$head$macro$tail";
  68.         }
  69.     }
  70.     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
  71.     $npath;
  72. }
  73.  
  74. =item fixpath
  75.  
  76. Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
  77. in any directory specification, in order to avoid juxtaposing two
  78. VMS-syntax directories when MM[SK] is run.  Also expands expressions which
  79. are all macro, so that we can tell how long the expansion is, and avoid
  80. overrunning DCL's command buffer when MM[KS] is running.
  81.  
  82. If optional second argument has a TRUE value, then the return string is
  83. a VMS-syntax directory specification, if it is FALSE, the return string
  84. is a VMS-syntax file specification, and if it is not specified, fixpath()
  85. checks to see whether it matches the name of a directory in the current
  86. default directory, and returns a directory or file specification accordingly.
  87.  
  88. =cut
  89.  
  90. sub fixpath {
  91.     my($self,$path,$force_path) = @_;
  92.     return '' unless $path;
  93.     $self = bless {} unless ref $self;
  94.     my($fixedpath,$prefix,$name);
  95.  
  96.     if ($path =~ /\s/) {
  97.       return join ' ',
  98.              map { $self->fixpath($_,$force_path) }
  99.          split /\s+/, $path;
  100.     }
  101.  
  102.     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
  103.         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
  104.             $fixedpath = vmspath($self->eliminate_macros($path));
  105.         }
  106.         else {
  107.             $fixedpath = vmsify($self->eliminate_macros($path));
  108.         }
  109.     }
  110.     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
  111.         my($vmspre) = $self->eliminate_macros("\$($prefix)");
  112.         # is it a dir or just a name?
  113.         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
  114.         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
  115.         $fixedpath = vmspath($fixedpath) if $force_path;
  116.     }
  117.     else {
  118.         $fixedpath = $path;
  119.         $fixedpath = vmspath($fixedpath) if $force_path;
  120.     }
  121.     # No hints, so we try to guess
  122.     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
  123.         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
  124.     }
  125.  
  126.     # Trim off root dirname if it's had other dirs inserted in front of it.
  127.     $fixedpath =~ s/\.000000([\]>])/$1/;
  128.     # Special case for VMS absolute directory specs: these will have had device
  129.     # prepended during trip through Unix syntax in eliminate_macros(), since
  130.     # Unix syntax has no way to express "absolute from the top of this device's
  131.     # directory tree".
  132.     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
  133.     $fixedpath;
  134. }
  135.  
  136. =back
  137.  
  138. =head2 Methods always loaded
  139.  
  140. =over 4
  141.  
  142. =item canonpath (override)
  143.  
  144. Removes redundant portions of file specifications according to VMS syntax.
  145.  
  146. =cut
  147.  
  148. sub canonpath {
  149.     my($self,$path) = @_;
  150.  
  151.     if ($path =~ m|/|) { # Fake Unix
  152.       my $pathify = $path =~ m|/\Z(?!\n)|;
  153.       $path = $self->SUPER::canonpath($path);
  154.       if ($pathify) { return vmspath($path); }
  155.       else          { return vmsify($path);  }
  156.     }
  157.     else {
  158.     $path =~ tr/<>/[]/;            # < and >       ==> [ and ]
  159.     $path =~ s/\]\[\./\.\]\[/g;        # ][.        ==> .][
  160.     $path =~ s/\[000000\.\]\[/\[/g;        # [000000.][    ==> [
  161.     $path =~ s/\[000000\./\[/g;        # [000000.    ==> [
  162.     $path =~ s/\.\]\[000000\]/\]/g;        # .][000000]    ==> ]
  163.     $path =~ s/\.\]\[/\./g;            # foo.][bar     ==> foo.bar
  164.     1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
  165.                         # That loop does the following
  166.                         # with any amount of dashes:
  167.                         # .-.-.        ==> .--.
  168.                         # [-.-.        ==> [--.
  169.                         # .-.-]        ==> .--]
  170.                         # [-.-]        ==> [--]
  171.     1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
  172.                         # That loop does the following
  173.                         # with any amount (minimum 2)
  174.                         # of dashes:
  175.                         # .foo.--.    ==> .-.
  176.                         # .foo.--]    ==> .-]
  177.                         # [foo.--.    ==> [-.
  178.                         # [foo.--]    ==> [-]
  179.                         #
  180.                         # And then, the remaining cases
  181.     $path =~ s/\[\.-/[-/;            # [.-        ==> [-
  182.     $path =~ s/\.[^\]\.]+\.-\./\./g;    # .foo.-.    ==> .
  183.     $path =~ s/\[[^\]\.]+\.-\./\[/g;    # [foo.-.    ==> [
  184.     $path =~ s/\.[^\]\.]+\.-\]/\]/g;    # .foo.-]    ==> ]
  185.     $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-]       ==> [000000]
  186.     $path =~ s/\[\]//;            # []        ==>
  187.     return $path;
  188.     }
  189. }
  190.  
  191. =item catdir
  192.  
  193. Concatenates a list of file specifications, and returns the result as a
  194. VMS-syntax directory specification.  No check is made for "impossible"
  195. cases (e.g. elements other than the first being absolute filespecs).
  196.  
  197. =cut
  198.  
  199. sub catdir {
  200.     my ($self,@dirs) = @_;
  201.     my $dir = pop @dirs;
  202.     @dirs = grep($_,@dirs);
  203.     my $rslt;
  204.     if (@dirs) {
  205.     my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
  206.     my ($spath,$sdir) = ($path,$dir);
  207.     $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; 
  208.     $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
  209.     $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
  210.  
  211.     # Special case for VMS absolute directory specs: these will have had device
  212.     # prepended during trip through Unix syntax in eliminate_macros(), since
  213.     # Unix syntax has no way to express "absolute from the top of this device's
  214.     # directory tree".
  215.     if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
  216.     }
  217.     else {
  218.     if    (not defined $dir or not length $dir) { $rslt = ''; }
  219.     elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s)          { $rslt = $dir; }
  220.     else                                        { $rslt = vmspath($dir); }
  221.     }
  222.     return $self->canonpath($rslt);
  223. }
  224.  
  225. =item catfile
  226.  
  227. Concatenates a list of file specifications, and returns the result as a
  228. VMS-syntax file specification.
  229.  
  230. =cut
  231.  
  232. sub catfile {
  233.     my ($self,@files) = @_;
  234.     my $file = $self->canonpath(pop @files);
  235.     @files = grep($_,@files);
  236.     my $rslt;
  237.     if (@files) {
  238.     my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
  239.     my $spath = $path;
  240.     $spath =~ s/\.dir\Z(?!\n)//;
  241.     if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
  242.         $rslt = "$spath$file";
  243.     }
  244.     else {
  245.         $rslt = $self->eliminate_macros($spath);
  246.         $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
  247.     }
  248.     }
  249.     else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
  250.     return $self->canonpath($rslt);
  251. }
  252.  
  253.  
  254. =item curdir (override)
  255.  
  256. Returns a string representation of the current directory: '[]'
  257.  
  258. =cut
  259.  
  260. sub curdir {
  261.     return '[]';
  262. }
  263.  
  264. =item devnull (override)
  265.  
  266. Returns a string representation of the null device: '_NLA0:'
  267.  
  268. =cut
  269.  
  270. sub devnull {
  271.     return "_NLA0:";
  272. }
  273.  
  274. =item rootdir (override)
  275.  
  276. Returns a string representation of the root directory: 'SYS$DISK:[000000]'
  277.  
  278. =cut
  279.  
  280. sub rootdir {
  281.     return 'SYS$DISK:[000000]';
  282. }
  283.  
  284. =item tmpdir (override)
  285.  
  286. Returns a string representation of the first writable directory
  287. from the following list or '' if none are writable:
  288.  
  289.     sys$scratch:
  290.     $ENV{TMPDIR}
  291.  
  292. Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
  293. is tainted, it is not used.
  294.  
  295. =cut
  296.  
  297. my $tmpdir;
  298. sub tmpdir {
  299.     return $tmpdir if defined $tmpdir;
  300.     my $self = shift;
  301.     $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
  302. }
  303.  
  304. =item updir (override)
  305.  
  306. Returns a string representation of the parent directory: '[-]'
  307.  
  308. =cut
  309.  
  310. sub updir {
  311.     return '[-]';
  312. }
  313.  
  314. =item case_tolerant (override)
  315.  
  316. VMS file specification syntax is case-tolerant.
  317.  
  318. =cut
  319.  
  320. sub case_tolerant {
  321.     return 1;
  322. }
  323.  
  324. =item path (override)
  325.  
  326. Translate logical name DCL$PATH as a searchlist, rather than trying
  327. to C<split> string value of C<$ENV{'PATH'}>.
  328.  
  329. =cut
  330.  
  331. sub path {
  332.     my (@dirs,$dir,$i);
  333.     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
  334.     return @dirs;
  335. }
  336.  
  337. =item file_name_is_absolute (override)
  338.  
  339. Checks for VMS directory spec as well as Unix separators.
  340.  
  341. =cut
  342.  
  343. sub file_name_is_absolute {
  344.     my ($self,$file) = @_;
  345.     # If it's a logical name, expand it.
  346.     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
  347.     return scalar($file =~ m!^/!s             ||
  348.           $file =~ m![<\[][^.\-\]>]!  ||
  349.           $file =~ /:[^<\[]/);
  350. }
  351.  
  352. =item splitpath (override)
  353.  
  354. Splits using VMS syntax.
  355.  
  356. =cut
  357.  
  358. sub splitpath {
  359.     my($self,$path) = @_;
  360.     my($dev,$dir,$file) = ('','','');
  361.  
  362.     vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
  363.     return ($1 || '',$2 || '',$3);
  364. }
  365.  
  366. =item splitdir (override)
  367.  
  368. Split dirspec using VMS syntax.
  369.  
  370. =cut
  371.  
  372. sub splitdir {
  373.     my($self,$dirspec) = @_;
  374.     $dirspec =~ tr/<>/[]/;            # < and >    ==> [ and ]
  375.     $dirspec =~ s/\]\[\./\.\]\[/g;        # ][.        ==> .][
  376.     $dirspec =~ s/\[000000\.\]\[/\[/g;        # [000000.][    ==> [
  377.     $dirspec =~ s/\[000000\./\[/g;        # [000000.    ==> [
  378.     $dirspec =~ s/\.\]\[000000\]/\]/g;        # .][000000]    ==> ]
  379.     $dirspec =~ s/\.\]\[/\./g;            # foo.][bar    ==> foo.bar
  380.     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
  381.                         # That loop does the following
  382.                         # with any amount of dashes:
  383.                         # .--.        ==> .-.-.
  384.                         # [--.        ==> [-.-.
  385.                         # .--]        ==> .-.-]
  386.                         # [--]        ==> [-.-]
  387.     $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
  388.     my(@dirs) = split('\.', vmspath($dirspec));
  389.     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
  390.     @dirs;
  391. }
  392.  
  393.  
  394. =item catpath (override)
  395.  
  396. Construct a complete filespec using VMS syntax
  397.  
  398. =cut
  399.  
  400. sub catpath {
  401.     my($self,$dev,$dir,$file) = @_;
  402.     
  403.     # We look for a volume in $dev, then in $dir, but not both
  404.     my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
  405.     $dev = $dir_volume unless length $dev;
  406.     $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
  407.     
  408.     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
  409.     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
  410.     if (length($dev) or length($dir)) {
  411.       $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
  412.       $dir = vmspath($dir);
  413.     }
  414.     "$dev$dir$file";
  415. }
  416.  
  417. =item abs2rel (override)
  418.  
  419. Use VMS syntax when converting filespecs.
  420.  
  421. =cut
  422.  
  423. sub abs2rel {
  424.     my $self = shift;
  425.     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
  426.         if grep m{/}, @_;
  427.  
  428.     my($path,$base) = @_;
  429.     $base = $self->_cwd() unless defined $base and length $base;
  430.  
  431.     for ($path, $base) { $_ = $self->canonpath($_) }
  432.  
  433.     # Are we even starting $path on the same (node::)device as $base?  Note that
  434.     # logical paths or nodename differences may be on the "same device" 
  435.     # but the comparison that ignores device differences so as to concatenate 
  436.     # [---] up directory specs is not even a good idea in cases where there is 
  437.     # a logical path difference between $path and $base nodename and/or device.
  438.     # Hence we fall back to returning the absolute $path spec
  439.     # if there is a case blind device (or node) difference of any sort
  440.     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
  441.     # (this module needs to run on non VMS platforms after all).
  442.     
  443.     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
  444.     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
  445.     return $path unless lc($path_volume) eq lc($base_volume);
  446.  
  447.     for ($path, $base) { $_ = $self->rel2abs($_) }
  448.  
  449.     # Now, remove all leading components that are the same
  450.     my @pathchunks = $self->splitdir( $path_directories );
  451.     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
  452.     my @basechunks = $self->splitdir( $base_directories );
  453.     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
  454.  
  455.     while ( @pathchunks && 
  456.             @basechunks && 
  457.             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
  458.           ) {
  459.         shift @pathchunks ;
  460.         shift @basechunks ;
  461.     }
  462.  
  463.     # @basechunks now contains the directories to climb out of,
  464.     # @pathchunks now has the directories to descend in to.
  465.     $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
  466.     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
  467. }
  468.  
  469.  
  470. =item rel2abs (override)
  471.  
  472. Use VMS syntax when converting filespecs.
  473.  
  474. =cut
  475.  
  476. sub rel2abs {
  477.     my $self = shift ;
  478.     my ($path,$base ) = @_;
  479.     return undef unless defined $path;
  480.     if ($path =~ m/\//) {
  481.     $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
  482.            ? vmspath($path)             # whether it's a directory
  483.            : vmsify($path) );
  484.     }
  485.     $base = vmspath($base) if defined $base && $base =~ m/\//;
  486.     # Clean up and split up $path
  487.     if ( ! $self->file_name_is_absolute( $path ) ) {
  488.         # Figure out the effective $base and clean it up.
  489.         if ( !defined( $base ) || $base eq '' ) {
  490.             $base = $self->_cwd;
  491.         }
  492.         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  493.             $base = $self->rel2abs( $base ) ;
  494.         }
  495.         else {
  496.             $base = $self->canonpath( $base ) ;
  497.         }
  498.  
  499.         # Split up paths
  500.         my ( $path_directories, $path_file ) =
  501.             ($self->splitpath( $path ))[1,2] ;
  502.  
  503.         my ( $base_volume, $base_directories ) =
  504.             $self->splitpath( $base ) ;
  505.  
  506.         $path_directories = '' if $path_directories eq '[]' ||
  507.                                   $path_directories eq '<>';
  508.         my $sep = '' ;
  509.         $sep = '.'
  510.             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
  511.                  $path_directories =~ m{^[^.\[<]}s
  512.             ) ;
  513.         $base_directories = "$base_directories$sep$path_directories";
  514.         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
  515.  
  516.         $path = $self->catpath( $base_volume, $base_directories, $path_file );
  517.    }
  518.  
  519.     return $self->canonpath( $path ) ;
  520. }
  521.  
  522.  
  523. =back
  524.  
  525. =head1 COPYRIGHT
  526.  
  527. Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
  528.  
  529. This program is free software; you can redistribute it and/or modify
  530. it under the same terms as Perl itself.
  531.  
  532. =head1 SEE ALSO
  533.  
  534. See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  535. implementation of these methods, not the semantics.
  536.  
  537. An explanation of VMS file specs can be found at
  538. L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
  539.  
  540. =cut
  541.  
  542. 1;
  543.